home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / eumake.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  4KB  |  128 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ; make makefile dependencies
  8. ; RJB Initial version Feb 91.
  9. ;
  10. ; RJB Rename unionq to remove-repetitions 13 Mar 91
  11.  
  12. (defmodule eumake (standard)
  13.  
  14.   ()
  15.  
  16.   ; (MD 'foo '(bar baz wop)) will make a makefile for target foo using the
  17.   ; modules bar.em, baz.em and wop.em
  18.   (defun MD (name mods)
  19.     (let* ((deplists (mapcar module-depends mods))
  20.        (modlist (nreverse (tsort
  21.              (mapcan (lambda (x)
  22.                    (mapcar (lambda (y) (cons (car x) y))
  23.                        (cdr x)))
  24.                  deplists)))))
  25.       (format t ".SUFFIXES:~%.SUFFIXES: .em .o~%~%")
  26.       (format t "EU2C = eu2c~%")
  27.       (format t "ECC  = ecc~%~%")
  28.       (format t ".em.o:~%~t$(EU2C) $*~%~t$(ECC) -c $*.c~%")
  29.       (format t "~trm -f $*.c $*.xm~%~%")
  30.       (format t "# The order of these is important -- do not change!~%")
  31.       (format t "SRCS =")
  32.       (mapc (lambda (mod)
  33.           (when (memq mod mods) (format t " ~a.em" mod)))
  34.         modlist)
  35.       (format t "~%~%OBJS =")
  36.       (mapc (lambda (mod)
  37.               (when (memq mod mods) (format t " ~a.o" mod)))
  38.           modlist)
  39.       (format t "~%~%~a: $(OBJS)" name)
  40.       (format t "~%~t$(ECC) -o ~a $(OBJS)~%~%" name)
  41.       (mapc (lambda (deplist)
  42.           (format t "~a.o:" (car deplist))
  43.           (mapc (lambda (dep)
  44.               (when (memq dep mods)
  45.                 (format t " ~a.o" dep)))
  46.             (cdr deplist))
  47.           (format t "~%"))
  48.         deplists)
  49.       (format t "~%clean:~%~trm -f *.c *.o *.i *.xm ~a~%" name)))
  50.  
  51.   (defun name-to-file (filename)
  52.     (unless (stringp filename)
  53.         (setq filename (symbol-name filename)))
  54.     (let ((len (string-length filename)))
  55.     (if (and (> len 3)
  56.         (equal (string-slice filename (- len 3) (- len 1)) ".em"))
  57.     filename
  58.         (string-append filename ".em"))))
  59.  
  60.   ; given a module name, return a list
  61.   ; (name . modules it depends on)
  62.   (defun module-depends (filename)
  63.     (let* ((fn (open (name-to-file filename) 'input))
  64.        (spec (caddr (read fn))))
  65.       (close fn)
  66.       (cons filename (remove-repetitions (do-spec spec)))))
  67.  
  68.   (defconstant stderr (standard-error-stream))
  69.  
  70.   (defun do-spec (spec)
  71.     (if (atom spec) (list spec)
  72.       (let ((directive (car spec)))
  73.     (when (memq directive '(expose union)) (old-spec directive))
  74.     (cond ((eq directive 'expose) (cdr spec))
  75.           ((memq directive '(except only rename))
  76.            (if (or (atom (cdr spec))
  77.                (atom (cddr spec))) (dodgy-spec spec)
  78.          (mapcan do-spec (cddr spec))))
  79.           ((eq directive 'union)
  80.            (if (atom (cdr spec)) (dodgy-spec spec)
  81.          (mapcan do-spec (cdr spec))))
  82.           (t (mapcan do-spec spec))))))
  83.  
  84.   (defun old-spec (spec)
  85.     (format stderr "*** old style spec ~a~%" spec))
  86.  
  87.   (defun dodgy-spec (spec)
  88.     (format stderr "*** dodgy spec ~a~%" spec))
  89.  
  90.   (defun remove-repetitions u
  91.     (if (atom u) ()
  92.         (let ((table (make-table eq)))
  93.       (mapc (lambda (l)
  94.           (if (atom l) ()
  95.               (mapc (lambda (e) ((setter table-ref) table e t)) l)))
  96.         u)
  97.       (table-keys table))))
  98.  
  99.   (defun set-diffq (a b)
  100.     (mapcan (lambda (elt) (if (memq elt b) () (list elt))) a))
  101.  
  102.   ; takes a list of ( (obj1 . obj2) ... )
  103.   ; which means obj1 > obj2
  104.   ; return a lists of objs with largest first
  105.   (defun tsort (pairlist)
  106.     (if (atom pairlist) ()
  107.        (let* ((firsts (remove-repetitions (mapcar car pairlist)))
  108.           (lasts  (remove-repetitions (mapcar cdr pairlist)))
  109.           (only-firsts (set-diffq firsts lasts)))
  110.  
  111.      (when (null only-firsts)
  112.            (error "loop in tsort pairs" Internal-Error))
  113.  
  114.      (setq pairlist
  115.            (mapcan (lambda (apair)
  116.              (if (memq (car apair) only-firsts)
  117.                  ()
  118.                              (list apair)))
  119.                pairlist))
  120.  
  121.      (nconc only-firsts
  122.         (nconc (tsort pairlist)
  123.                (set-diffq lasts
  124.               (remove-repetitions (mapcar car pairlist)
  125.                           (mapcar cdr pairlist))))))))
  126.  
  127. )
  128.